home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / HTTP / Daemon.pm next >
Encoding:
Perl POD Document  |  1999-12-28  |  13.3 KB  |  570 lines
  1.  
  2. use strict;
  3.  
  4. package HTTP::Daemon;
  5.  
  6. =head1 NAME
  7.  
  8. HTTP::Daemon - a simple http server class
  9.  
  10. =head1 SYNOPSIS
  11.  
  12.   use HTTP::Daemon;
  13.   use HTTP::Status;
  14.  
  15.   $d = new HTTP::Daemon;
  16.   print "Please contact me at: <URL:", $d->url, ">\n";
  17.   while ($c = $d->accept) {
  18.       $r = $c->get_request;
  19.       if ($r) {
  20.       if ($r->method eq 'GET' and $r->url->path eq "/xyzzy") {
  21.           $c->send_file_response("/etc/passwd");
  22.       } else {
  23.           $c->send_error(RC_FORBIDDEN)
  24.       }
  25.       }
  26.       $c = undef;  # close connection
  27.   }
  28.  
  29. =head1 DESCRIPTION
  30.  
  31. Instances of the I<HTTP::Daemon> class are HTTP/1.1 servers that
  32. listens on a socket for incoming requests. The I<HTTP::Daemon> is a
  33. sub-class of I<IO::Socket::INET>, so you can do socket operations
  34. directly on it.
  35.  
  36. The accept() method will return when a connection from a client is
  37. available. The returned value will be a reference to a object of the
  38. I<HTTP::Daemon::ClientConn> class which is another I<IO::Socket::INET>
  39. subclass. Calling the get_request() method on this object will read
  40. data from the client and return an I<HTTP::Request> object reference.
  41.  
  42. This HTTP daemon does not fork(2) for you.  Your application, i.e. the
  43. user of the I<HTTP::Daemon> is reponsible for forking if that is
  44. desirable.  Also note that the user is responsible for generating
  45. responses that conforms to the HTTP/1.1 protocol.  The
  46. I<HTTP::Daemon::ClientConn> provide some methods that make this easier.
  47.  
  48. =head1 METHODS
  49.  
  50. The following is a list of methods that are new (or enhanced) relative
  51. to the I<IO::Socket::INET> base class.
  52.  
  53. =over 4
  54.  
  55. =cut
  56.  
  57.  
  58. use vars qw($VERSION @ISA $PROTO);
  59.  
  60. $VERSION = sprintf("%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/);
  61.  
  62. use IO::Socket ();
  63. @ISA=qw(IO::Socket::INET);
  64.  
  65. $PROTO = "HTTP/1.1";
  66.  
  67. =item $d = new HTTP::Daemon
  68.  
  69. The object constructor takes the same parameters as the
  70. I<IO::Socket::INET> constructor.  It can also be called without
  71. specifying any parameters. The daemon will then set up a listen queue
  72. of 5 connections and allocate some random port number.  A server
  73. that want to bind to some specific address on the standard HTTP port
  74. will be constructed like this:
  75.  
  76.   $d = new HTTP::Daemon
  77.         LocalAddr => 'www.someplace.com',
  78.         LocalPort => 80;
  79.  
  80. =cut
  81.  
  82. sub new
  83. {
  84.     my($class, %args) = @_;
  85.     $args{Listen} ||= 5;
  86.     $args{Proto}  ||= 'tcp';
  87.     my $self = $class->SUPER::new(%args);
  88.     return undef unless $self;
  89.  
  90.     my $host = $args{LocalAddr};
  91.     unless ($host) {
  92.     require Sys::Hostname;
  93.     $host = Sys::Hostname::hostname();
  94.     }
  95.     ${*$self}{'httpd_server_name'} = $host;
  96.     $self;
  97. }
  98.  
  99.  
  100. =item $c = $d->accept
  101.  
  102. Same as I<IO::Socket::accept> but will return an
  103. I<HTTP::Daemon::ClientConn> reference.  It will return undef if you
  104. have specified a timeout and no connection is made within that time.
  105.  
  106. =cut
  107.  
  108. sub accept
  109. {
  110.     my $self = shift;
  111.     my $sock = $self->SUPER::accept(@_);
  112.     if ($sock) {
  113.     $sock = bless $sock, "HTTP::Daemon::ClientConn";
  114.     ${*$sock}{'httpd_daemon'} = $self;
  115.     }
  116.     $sock;
  117. }
  118.  
  119.  
  120. =item $d->url
  121.  
  122. Returns a URL string that can be used to access the server root.
  123.  
  124. =cut
  125.  
  126. sub url
  127. {
  128.     my $self = shift;
  129.     my $url = "http://";
  130.     $url .= ${*$self}{'httpd_server_name'};
  131.     my $port = $self->sockport;
  132.     $url .= ":$port" if $port != 80;
  133.     $url .= "/";
  134.     $url;
  135. }
  136.  
  137.  
  138. =item $d->product_tokens
  139.  
  140. Returns the name that this server will use to identify itself.  This
  141. is the string that is sent with the I<Server> response header.
  142.  
  143. =cut
  144.  
  145. sub product_tokens
  146. {
  147.     "libwww-perl-daemon/$HTTP::Daemon::VERSION";
  148. }
  149.  
  150.  
  151. package HTTP::Daemon::ClientConn;
  152.  
  153. use vars '@ISA';
  154. use IO::Socket ();
  155. @ISA=qw(IO::Socket::INET);
  156.  
  157. use HTTP::Request  ();
  158. use HTTP::Response ();
  159. use HTTP::Status;
  160. use HTTP::Date qw(time2str);
  161. use URI::URL qw(url);
  162. use LWP::MediaTypes qw(guess_media_type);
  163. use Carp ();
  164.  
  165. my $CRLF = "\015\012";   # "\r\n" is not portable
  166.  
  167. =back
  168.  
  169. The I<HTTP::Daemon::ClientConn> is also a I<IO::Socket::INET>
  170. subclass. Instances of this class are returned by the accept() method
  171. of the I<HTTP::Daemon>.  The following additional methods are
  172. provided:
  173.  
  174. =over 4
  175.  
  176. =item $c->get_request
  177.  
  178. Will read data from the client and turn it into a I<HTTP::Request>
  179. object which is then returned. Will return undef if reading of the
  180. request failed.  If it fails, then the I<HTTP::Daemon::ClientConn>
  181. object ($c) should be discarded.
  182.  
  183. The $c->get_request method support HTTP/1.1 content bodies, including
  184. I<chunked> transfer encoding with footer and I<multipart/*> types.
  185.  
  186. =cut
  187.  
  188. sub get_request
  189. {
  190.     my $self = shift;
  191.     my $buf = "";
  192.     
  193.     my $timeout = $ {*$self}{'io_socket_timeout'};
  194.     my  $fdset = "";
  195.     vec($fdset, $self->fileno,1) = 1;
  196.  
  197.   READ_HEADER:
  198.     while (1) {
  199.     if ($timeout) {
  200.         return undef unless select($fdset,undef,undef,$timeout);
  201.     }
  202.     my $n = sysread($self, $buf, 1024, length($buf));
  203.     return undef if $n == 0;  # unexpected EOF
  204.     if ($buf =~ /^\w+[^\n]+HTTP\/\d+\.\d+\015?\012/) {
  205.         last READ_HEADER if $buf =~ /(\015?\012){2}/;
  206.     } elsif ($buf =~ /\012/) {
  207.         last READ_HEADER;  # HTTP/0.9 client
  208.     }
  209.     }
  210.     $buf =~ s/^(\w+)\s+(\S+)(?:\s+(HTTP\/\d+\.\d+))?[^\012]*\012//;
  211.     my $proto = $3 || "HTTP/0.9";
  212.     ${*$self}{'httpd_client_proto'} = $proto;
  213.     my $r = HTTP::Request->new($1, url($2, $self->daemon->url));
  214.     $r->protocol($proto);
  215.  
  216.     my($key, $val);
  217.   HEADER:
  218.     while ($buf =~ s/^([^\012]*)\012//) {
  219.     $_ = $1;
  220.     s/\015$//;
  221.     if (/^([\w\-]+)\s*:\s*(.*)/) {
  222.         $r->push_header($key, $val) if $key;
  223.         ($key, $val) = ($1, $2);
  224.     } elsif (/^\s+(.*)/) {
  225.         $val .= " $1";
  226.     } else {
  227.         last HEADER;
  228.     }
  229.     }
  230.     $r->push_header($key, $val) if $key;
  231.  
  232.     my $te  = $r->header('Transfer-Encoding');
  233.     my $ct  = $r->header('Content-Type');
  234.     my $len = $r->header('Content-Length');
  235.  
  236.     if ($te && lc($te) eq 'chunked') {
  237.     my $body = "";
  238.       CHUNK:
  239.     while (1) {
  240.         if ($buf =~ s/^([^\012]*)\012//) {
  241.         my $chunk_head = $1;
  242.         $chunk_head =~ /^([0-9A-Fa-f]+)/;
  243.         return undef unless length($1);
  244.         my $size = hex($1);
  245.         last CHUNK if $size == 0;
  246.  
  247.         my $missing = $size - length($buf);
  248.         $missing += 2; # also read CRLF at chunk end
  249.         $body .= $buf;
  250.         $buf = "";
  251.         while ($missing > 0) {
  252.             if ($timeout) {
  253.             return undef unless select($fdset,undef,undef,$timeout);
  254.             }
  255.             my $n = sysread($self, $body, $missing, length($body));
  256.             return undef if $n == 0;
  257.             $missing -= $n;
  258.         }
  259.         substr($body, -2, 2) = ''; # remove CRLF at end
  260.  
  261.         } else {
  262.         if ($timeout) {
  263.             return undef unless select($fdset,undef,undef,$timeout);
  264.         }
  265.         my $n = sysread($self, $buf, 2048, length($buf));
  266.         return undef if $n == 0;
  267.         }
  268.     }
  269.     $r->content($body);
  270.  
  271.     $r->remove_header('Transfer-Encoding');
  272.     $r->header('Content-Length', length($body));
  273.  
  274.     my($key, $val);
  275.       FOOTER:
  276.     while (1) {
  277.         if ($buf !~ /\012/) {
  278.         if ($timeout) {
  279.             return undef unless select($fdset,undef,undef,$timeout);
  280.         }
  281.         my $n = sysread($self, $buf, 2048, length($buf));
  282.         return undef if $n == 0;
  283.         } else {
  284.         $buf =~ s/^([^\012]*)\012//;
  285.         $_ = $1;
  286.         s/\015$//;
  287.         last FOOTER if length($_) == 0;
  288.  
  289.         if (/^([\w\-]+)\s*:\s*(.*)/) {
  290.             $r->push_header($key, $val) if $key;
  291.             ($key, $val) = ($1, $2);
  292.         } elsif (/^\s+(.*)/) {
  293.             $val .= " $1";
  294.         } else {
  295.             return undef;  # bad syntax
  296.         }
  297.         }
  298.     }
  299.     $r->push_header($key, $val) if $key;
  300.  
  301.     } elsif ($te) {
  302.     $self->send_error(501);
  303.     return undef;
  304.  
  305.     } elsif ($ct && lc($ct) =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*(\w+)/) {
  306.     my $boundary = "$CRLF--$1--$CRLF";
  307.     while (index($buf, $boundary) < 0) {
  308.         if ($timeout) {
  309.         return undef unless select($fdset,undef,undef,$timeout);
  310.         }
  311.         my $n = sysread($self, $buf, 2048, length($buf));
  312.         return undef if $n == 0;
  313.     }
  314.     $r->content($buf);
  315.  
  316.     } elsif ($len) {
  317.  
  318.     $len -= length($buf);
  319.     while ($len > 0) {
  320.         if ($timeout) {
  321.         return undef unless select($fdset,undef,undef,$timeout);
  322.         }
  323.         my $n = sysread($self, $buf, $len, length($buf));
  324.         return undef if $n == 0;
  325.         $len -= $n;
  326.     }
  327.     $r->content($buf);
  328.  
  329.     }
  330.  
  331.     $r;
  332. }
  333.  
  334.  
  335. =item $c->antique_client
  336.  
  337. Returns TRUE if the client speaks the HTTP/0.9 protocol, i.e. no
  338. status code or headers should be returned.
  339.  
  340. =cut
  341.  
  342. sub antique_client
  343. {
  344.     my $self = shift;
  345.     ${*$self}{'httpd_client_proto'} eq 'HTTP/0.9';
  346. }
  347.  
  348.  
  349. =item $c->send_status_line( [$code, [$mess, [$proto]]] )
  350.  
  351. Sends the status line back to the client.
  352.  
  353. =cut
  354.  
  355. sub send_status_line
  356. {
  357.     my($self, $status, $message, $proto) = @_;
  358.     return if $self->antique_client;
  359.     $status  ||= RC_OK;
  360.     $message ||= status_message($status);
  361.     $proto   ||= $HTTP::Daemon::PROTO;
  362.     print $self "$proto $status $message$CRLF";
  363. }
  364.  
  365.  
  366. sub send_crlf
  367. {
  368.     my $self = shift;
  369.     print $self $CRLF;
  370. }
  371.  
  372.  
  373. =item $c->send_basic_header( [$code, [$mess, [$proto]]] )
  374.  
  375. Sends the status line and the "Date:" and "Server:" headers back to
  376. the client.
  377.  
  378. =cut
  379.  
  380. sub send_basic_header
  381. {
  382.     my $self = shift;
  383.     return if $self->antique_client;
  384.     $self->send_status_line(@_);
  385.     print $self "Date: ", time2str(time), $CRLF;
  386.     my $product = $self->daemon->product_tokens;
  387.     print $self "Server: $product$CRLF" if $product;
  388. }
  389.  
  390.  
  391. =item $c->send_response( [$res] )
  392.  
  393. Takes a I<HTTP::Response> object as parameter and send it back to the
  394. client as the response.
  395.  
  396. =cut
  397.  
  398. sub send_response
  399. {
  400.     my $self = shift;
  401.     my $res = shift;
  402.     if (!ref $res) {
  403.     $res ||= RC_OK;
  404.     $res = HTTP::Response->new($res, @_);
  405.     }
  406.     unless ($self->antique_client) {
  407.     $self->send_basic_header($res->code, $res->message, $res->protocol);
  408.     print $self $res->headers_as_string($CRLF);
  409.     print $self $CRLF;  # separates headers and content
  410.     }
  411.     print $self $res->content;
  412. }
  413.  
  414.  
  415. =item $c->send_redirect( $loc, [$code, [$entity_body]] )
  416.  
  417. Sends a redirect response back to the client.  The location ($loc) can
  418. be an absolute or a relative URL. The $code must be one the redirect
  419. status codes, and it defaults to "301 Moved Permanently"
  420.  
  421. =cut
  422.  
  423. sub send_redirect
  424. {
  425.     my($self, $loc, $status, $content) = @_;
  426.     $status ||= RC_MOVED_PERMANENTLY;
  427.     Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
  428.     $self->send_basic_header($status);
  429.     $loc = url($loc, $self->daemon->url) unless ref($loc);
  430.     $loc = $loc->abs;
  431.     print $self "Location: $loc$CRLF";
  432.     if ($content) {
  433.     my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
  434.     print $self "Content-Type: $ct$CRLF";
  435.     }
  436.     print $self $CRLF;
  437.     print $self $content if $content;
  438. }
  439.  
  440.  
  441. =item $c->send_error( [$code, [$error_message]] )
  442.  
  443. Send an error response back to the client.  If the $code is missing a
  444. "Bad Request" error is reported.  The $error_message is a string that
  445. is incorporated in the body of the HTML entity body.
  446.  
  447. =cut
  448.  
  449. sub send_error
  450. {
  451.     my($self, $status, $error) = @_;
  452.     $status ||= RC_BAD_REQUEST;
  453.     Carp::croak("Status '$status' is not an error") unless is_error($status);
  454.     my $mess = status_message($status);
  455.     $error  ||= "";
  456.     unless ($self->antique_client) {
  457.         $self->send_basic_header($status);
  458.         print $self "Content-Type: text/html$CRLF";
  459.         print $self $CRLF;
  460.     }
  461.     print $self <<EOT;
  462. <title>$status $mess</title>
  463. <h1>$status $mess</h1>
  464. $error
  465. EOT
  466.     $status;
  467. }
  468.  
  469.  
  470. =item $c->send_file_response($filename)
  471.  
  472. Send back a response with the specified $filename as content.  If the
  473. file happen to be a directory we will generate a HTML index for it.
  474.  
  475. =cut
  476.  
  477. sub send_file_response
  478. {
  479.     my($self, $file) = @_;
  480.     if (-d $file) {
  481.     $self->send_dir($file);
  482.     } elsif (-f _) {
  483.     local(*F);
  484.     sysopen(F, $file, 0) or 
  485.       return $self->send_error(RC_FORBIDDEN);
  486.     my($ct,$ce) = guess_media_type($file);
  487.     my($size,$mtime) = (stat _)[7,9];
  488.     unless ($self->antique_client) {
  489.         $self->send_basic_header;
  490.         print $self "Content-Type: $ct$CRLF";
  491.         print $self "Content-Encoding: $ce$CRLF" if $ce;
  492.         print $self "Content-Length: $size$CRLF";
  493.         print $self "Last-Modified: ", time2str($mtime), "$CRLF";
  494.         print $self $CRLF;
  495.     }
  496.     $self->send_file(\*F);
  497.     return RC_OK;
  498.     } else {
  499.     $self->send_error(RC_NOT_FOUND);
  500.     }
  501. }
  502.  
  503.  
  504. sub send_dir
  505. {
  506.     my($self, $dir) = @_;
  507.     $self->send_error(RC_NOT_FOUND) unless -d $dir;
  508.     $self->send_error(RC_NOT_IMPLEMENTED);
  509. }
  510.  
  511.  
  512. =item $c->send_file($fd);
  513.  
  514. Copies the file back to the client.  The file can be a string (which
  515. will be interpreted as a filename) or a reference to a glob.
  516.  
  517. =cut
  518.  
  519. sub send_file
  520. {
  521.     my($self, $file) = @_;
  522.     my $opened = 0;
  523.     if (!ref($file)) {
  524.     local(*F);
  525.     open(F, $file) || return undef;
  526.     $file = \*F;
  527.     $opened++;
  528.     }
  529.     my $cnt = 0;
  530.     my $buf = "";
  531.     my $n;
  532.     while ($n = sysread($file, $buf, 8*1024)) {
  533.     last if $n <= 0;
  534.     $cnt += $n;
  535.     print $self $buf;
  536.     }
  537.     close($file) if $opened;
  538.     $cnt;
  539. }
  540.  
  541.  
  542. =item $c->daemon
  543.  
  544. Return a reference to the corresponding I<HTTP::Daemon> object.
  545.  
  546. =cut
  547.  
  548. sub daemon
  549. {
  550.     my $self = shift;
  551.     ${*$self}{'httpd_daemon'};
  552. }
  553.  
  554. =back
  555.  
  556. =head1 SEE ALSO
  557.  
  558. L<IO::Socket>, L<Apache>
  559.  
  560. =head1 COPYRIGHT
  561.  
  562. Copyright 1996, Gisle Aas
  563.  
  564. This library is free software; you can redistribute it and/or
  565. modify it under the same terms as Perl itself.
  566.  
  567. =cut
  568.  
  569. 1;
  570.